Cream of the Crop 25/Cream of the Crop 25.iso/program/fpk65_66.zip/DEMO/DEMO.PP

Text File | 1997-01-30 | 5KB | 249 lines

program testgraf;

uses crt,graph,hex;

var maxx,maxy : longint;
    gd,gm     : integer;
    MaxColors : Longint;
    Drive     : String;

{$IFDEF TURBO}
{$I STDCOLOR.PPI}
{$ENDIF}

procedure Dummy;begin end;

function Int2Str(value:LongInt):String;
var s:string;
begin
 str(value,s);
 int2str:=s;
end;

procedure SetStandartColor(Nr:Integer);
begin
  nr:=nr and $ff;
  if MaxColors>256 then SetColor(stdcolors[nr]) else SetColor(nr);
end;

procedure SetStandartFillStyle(a:word;b:longint);
begin
  b:=b and $FF;
  if MaxColors>256 then SetFillStyle(a,stdcolors[b]) else SetFillStyle(a,b);
end;

procedure SetStandartFillPattern(a:FillPatternType;b:longint);
begin
  b:=b and $ff;
  if MaxColors>256 then SetFillPattern(a,stdcolors[b]) else SetFillPattern(a,b);
end;

procedure FullViewPort;
begin
  SetViewPort(0,0,maxx,maxy,ClipOn);
end;

procedure MainWindow(Header:String);
var h,i:Integer;
begin
  FullViewport;
  ClearDevice;
  h:=TextHeight('M');
  SetTextStyle(defaultfont,HorizDir,1);
  SetTextJustify(centertext,toptext);
  SetStandartFillStyle(solidfill,blue);
  SetStandartColor(white);
  for i:=0 to h+10 do begin
    setcolor((i shl 24)+$10000020+(i shl 3));
    line(0,i,maxx,i);
  end;
  SetStandartcolor(white);
  rectangle(0,0,maxx,maxy);
  line(0,h+11,maxx,h+11);
  OutTextXY(maxx shr 1,5,Header);
  SetViewPort(1,h+12,maxx-1,maxy-1,clipon);
end;

procedure RandomDots;
var VP  : Viewporttype;
    x,y : integer;
begin
  MainWindow('Randomdots');
  GetViewSettings(VP);
  with VP do begin
    x:=x2-x1; y:=y2-y1;
  end;
  Randomize;
  repeat
    PutPixel(random(x),random(y),random(maxcolors));
  until keypressed;
  readkey;
end;

procedure RandomCircle;
var VP  : Viewporttype;
    x,y : integer;
begin
  MainWindow('Randomcircles');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1; y:=VP.y2-VP.y1;
  Randomize;
  repeat
    SetStandartcolor(random(250)+1);
    Circle(random(x),random(y),random(100));
  until keypressed;
  readkey;
end;

procedure RandomArc;
var VP  : Viewporttype;
    x,y : integer;
    count:integer;
begin
  MainWindow('RandomArcs');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1; y:=VP.y2-VP.y1;
  Randomize;
  count:=0;
  repeat
    count:=count+1;
    SetStandartcolor(random(250)+1);
    Arc(random(x),random(y),random(180),random(360),random(100));
    if count=2000 then begin
      clearviewport;
      count:=0;
    end;
  until keypressed;
  readkey;
end;

procedure RandomLine;
var VP  : Viewporttype;
    x,y : integer;
begin
  MainWindow('Randomlines');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1+100; y:=VP.y2-VP.y1+100;
  Randomize;
  repeat
    SetStandartcolor(random(250)+1);
    line(random(x)-50,random(y)-50,random(x)-50,random(y)-50);
  until keypressed;
  readkey;
end;

procedure Setcolordemo;
var VP      : Viewporttype;
    x,y,i,j : integer;
begin
  MainWindow('SetColordemo');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1; y:=VP.y2-VP.y1;
  for i:=0 to y do
  begin
    j:=(i mod 240)+$10;
    SetColor((j shl 24)+j);
    line(0,i,x,i);
  end;
  readkey;
  { This works only in 256 color modes !!! }
  if GetMaxColor = $FF then begin
    for i:=$10 to $ff do SetColor((i shl 24)+(i shl 8));
    readkey;
    for i:=$10 to $ff do SetColor((i shl 24)+(i shl 16));
    readkey;
    for i:=$10 to $ff do SetColor((i shl 24)+(i shl 16)+(i shl 8)+i);
    readkey;
  end;
end;

procedure RandomBars;
var VP  : Viewporttype;
    x,y : integer;
    x1,y1,x2,y2:Integer;
begin
  MainWindow('Randombars');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1; y:=VP.y2-VP.y1;
  Randomize;
  repeat
    SetStandartFillStyle(random(11),random(250)+1);
    x1:=random(x)-50; y1:=random(y)-50;
    x2:=x1+10+random(x shr 1); y2:=y1+10+random(y shr 1);
    Bar(x1,y1,x2,y2);
    Rectangle(x1,y1,x2,y2);
  until keypressed;
  readkey;
end;

procedure RandomEllipse;
var VP  : Viewporttype;
    x,y : integer;
    x1,y1,x2,y2:Integer;
begin
  MainWindow('Randomfillellipse');
  GetViewSettings(VP);
  x:=VP.x2-VP.x1; y:=VP.y2-VP.y1;
  Randomize;
  SetLineStyle(1,xorput,1);
  repeat
    SetStandartFillStyle(random(11),random(250)+1);
    x1:=random(x); y1:=random(y);
    x2:=random(100)+20; y2:=random(100)+20;
    FillEllipse(x1,y1,x2,y2);
  until keypressed;
  SetLineStyle(1,normalput,1);
  readkey;
end;

{$IFDEF FPK}
procedure RandomTriangle;
var VP    : Viewporttype;
    x,y   : integer;
    a,b,c : Pointtype;
begin
  MainWindow('Randomtriangles');
  GetViewSettings(VP);
  x:=VP.x2 - VP.x1 + 100;
  y:=VP.y2 - VP.y1 + 100;
  Randomize;
  SetLineStyle(1,xorput,1);
  repeat
    SetStandartFillStyle(random(11),random(250)+1);
    a.x:=random(x)-50; a.y:=random(y)-50;
    b.x:=random(x)-50; b.y:=random(y)-50;
    c.x:=random(x)-50; c.y:=random(y)-50;
    FillTriangle(a,b,c);
  until keypressed;
  SetLineStyle(1,normalput,1);
  readkey;
end;
{$ENDIF}

begin
  Drive:=ParamStr(0)[1];
{$IFDEF FPK}
  GD:=1;
  GM:=$103;
{$ENDIF}
{$IFDEF TURBO}
  GD := InstallUserDriver('SVGA256',@Dummy);
  GM := 2;
{$ENDIF}
  InitGraph(GD,GM,Drive+':\PP\VESA\CHAR');
  Maxx:=GetMaxX;
  Maxy:=GetMaxY;
  MaxColors:=GetMaxColor;
  RandomDots;
  RandomCircle;
  RandomArc;
  RandomBars;
  RandomEllipse;
  RandomLine;
{$IFDEF FPK}
  RandomTriangle;
  SetColorDemo;
{$ENDIF}
  Closegraph;
end.